home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / eval.scm < prev    next >
Text File  |  1999-04-19  |  6KB  |  147 lines
  1. ; "eval.scm", Eval proposed by Guillermo (Bill) J. Rozas for R5RS.
  2. ; Copyright (c) 1997, 1998 Aubrey Jaffer
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;; Rather than worry over the status of all the optional procedures,
  21. ;;; just require as many as possible.
  22.  
  23. (require 'rev4-optional-procedures)
  24. (require 'dynamic-wind)
  25. (require 'transcript)
  26. (require 'with-file)
  27. (require 'values)
  28.  
  29. (define eval:make-environment
  30.   (let ((eval-1 slib:eval))
  31.     (lambda (identifiers)
  32.       ((lambda args args)
  33.        #f
  34.        identifiers
  35.        (lambda (expression)
  36.      (eval-1 `(lambda ,identifiers ,expression)))))))
  37.  
  38. (define eval:capture-environment!
  39.   (let ((set-car! set-car!)
  40.     (eval-1 slib:eval)
  41.     (apply apply))
  42.     (lambda (environment)
  43.       (set-car!
  44.        environment
  45.        (apply (lambda (environment-values identifiers procedure)
  46.         (eval-1 `((lambda args args) ,@identifiers)))
  47.           environment)))))
  48.  
  49. (define interaction-environment
  50.   (let ((env (eval:make-environment '())))
  51.     (lambda () env)))
  52.  
  53. ;;; null-environment is set by first call to scheme-report-environment at
  54. ;;; the end of this file.
  55. (define null-environment #f)
  56.  
  57. (define scheme-report-environment
  58.   (let* ((r4rs-procedures
  59.       (append
  60.        (cond ((provided? 'inexact)
  61.           (append
  62.            '(acos angle asin atan cos exact->inexact exp
  63.               expt imag-part inexact->exact log magnitude
  64.               make-polar make-rectangular real-part sin
  65.               sqrt tan)
  66.            (if (let ((n (string->number "1/3")))
  67.              (and (number? n) (exact? n)))
  68.                '(denominator numerator)
  69.                '())))
  70.          (else '()))
  71.        (cond ((provided? 'rationalize)
  72.           '(rationalize))
  73.          (else '()))
  74.        (cond ((provided? 'delay)
  75.           '(force))
  76.          (else '()))
  77.        (cond ((provided? 'char-ready?)
  78.           '(char-ready?))
  79.          (else '()))
  80.        '(* + - / < <= = > >= abs append apply assoc assq assv boolean?
  81.            caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar
  82.            caddar cadddr caddr cadr call-with-current-continuation
  83.            call-with-input-file call-with-output-file car cdaaar cdaadr
  84.            cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr
  85.            cdddr cddr cdr ceiling char->integer char-alphabetic?  char-ci<=?
  86.            char-ci<?  char-ci=?  char-ci>=?  char-ci>?  char-downcase
  87.            char-lower-case?  char-numeric?  char-upcase char-upper-case?
  88.            char-whitespace?  char<=?  char<?  char=?  char>=?  char>?  char?
  89.            close-input-port close-output-port complex?  cons
  90.            current-input-port current-output-port display eof-object?  eq?
  91.            equal?  eqv?  even?  exact?  floor for-each gcd inexact?
  92.            input-port?  integer->char integer?  lcm length list list->string
  93.            list->vector list-ref list-tail list?  load make-string
  94.            make-vector map max member memq memv min modulo negative?
  95.            newline not null?  number->string number?  odd?  open-input-file
  96.            open-output-file output-port?  pair?  peek-char positive?
  97.            procedure?  quotient rational?  read read-char real?  remainder
  98.            reverse round set-car!  set-cdr!  string string->list
  99.            string->number string->symbol string-append string-ci<=?
  100.            string-ci<?  string-ci=?  string-ci>=?  string-ci>?  string-copy
  101.            string-fill!  string-length string-ref string-set!  string<=?
  102.            string<?  string=?  string>=?  string>?  string?  substring
  103.            symbol->string symbol?  transcript-off transcript-on truncate
  104.            vector vector->list vector-fill!  vector-length vector-ref
  105.            vector-set!  vector?  with-input-from-file with-output-to-file
  106.            write write-char zero?
  107.            )))
  108.      (r5rs-procedures
  109.       (append
  110.        '(call-with-values dynamic-wind eval interaction-environment
  111.                   null-environment scheme-report-environment values)
  112.        r4rs-procedures))
  113.      (r4rs-environment (eval:make-environment r4rs-procedures))
  114.      (r5rs-environment (eval:make-environment r4rs-procedures)))
  115.     (let ((car car))
  116.       (lambda (version)
  117.     (cond ((car r5rs-environment))
  118.           (else
  119.            (let ((null-env (eval:make-environment r5rs-procedures)))
  120.          (set-car! null-env (map (lambda (i) #f) r5rs-procedures))
  121.          (set! null-environment (lambda version null-env)))
  122.            (eval:capture-environment! r4rs-environment)
  123.            (eval:capture-environment! r5rs-environment)))
  124.     (case version
  125.       ((4) r4rs-environment)
  126.       ((5) r5rs-environment)
  127.       (else (slib:error 'eval 'version version 'not 'available)))))))
  128.  
  129. (define eval
  130.   (let ((eval-1 slib:eval)
  131.     (apply apply)
  132.     (null? null?)
  133.     (eq? eq?))
  134.     (lambda (expression . environment)
  135.       (if (null? environment) (eval-1 expression)
  136.       (apply
  137.        (lambda (environment)
  138.          (if (eq? (interaction-environment) environment) (eval-1 expression)
  139.          (apply (lambda (environment-values identifiers procedure)
  140.               (apply (procedure expression) environment-values))
  141.             environment)))
  142.        environment)))))
  143. (set! slib:eval eval)
  144.  
  145. ;;; Now that all the R5RS procedures are defined, capture r5rs-environment.
  146. (and (scheme-report-environment 5) #t)
  147.